home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 2003 August / MW 8 2003 CD1.iso / Inside Macworld / Product News / gimp-1.2.4.sit / gimp-1.2.4 / plug-ins / perl / scm2perl < prev    next >
Encoding:
Text File  |  2001-08-30  |  10.3 KB  |  453 lines
  1. #!/usr/bin/perl
  2.  
  3. #require 5.005;
  4.  
  5. # Copyright Marc Lehmann <pcg@goof.com>
  6. #
  7. # This is part of the Gimp-Perl extension, and shares its copright with it.
  8.  
  9. # this file is called "the dong"
  10.  
  11. # TODO
  12. # more syntax ;) more functions ;) more exprns ;) more constants ;)
  13. # ui/args
  14. # too many parens
  15. # comments(!)
  16.  
  17. # This is distributed under the GPL (see COPYING.GNU for details).
  18.  
  19. =cut
  20.  
  21. =head1 NAME
  22.  
  23. scm2perl - convert script-fu to perl
  24.  
  25. =head1 SYNOPSIS
  26.  
  27.  scm2perl filename.scm...
  28.  
  29. =head1 DESCRIPTION
  30.  
  31. This program tries to convert Script-Fu (Scheme) scripts written for The
  32. Gimp into a Perl script.
  33.  
  34. Don't expect too much from this version. To run it, you need
  35. the Parse::RecDescent module from CPAN.
  36.  
  37. =head1 CONVERSION TIPS
  38.  
  39. =head2 PDB functions returning arrays
  40.  
  41. Perl knows the length of arrays, Script-Fu doesn't. Functions returning
  42. single arrays return them as a normal perl array, Functions returning
  43. more then one array return it as an array-ref. Script-Fu (and the
  44. converted script) expect to get a length argument and then the
  45. arguments. Each occurrence (common ones are C<gimp_list_images> or
  46. C<gimp_image_get_layers>) must be fixed by hand.
  47.  
  48. =head1 AUTHOR
  49.  
  50. Marc Lehmann <pcg@goof.com>
  51.  
  52. =head1 SEE ALSO
  53.  
  54. gimp(1), L<Gimp>.
  55.  
  56. =cut
  57.  
  58. $|=1;
  59.  
  60. use Parse::RecDescent;
  61.  
  62. $RD_HINT=1;
  63. #$RD_TRACE=1;
  64.  
  65. unless(@ARGV) {
  66.    print STDERR "Script-Fu to Perl Translator 1.0\n";
  67.    print STDERR "Usage: $0 file.scm ...\n";
  68.    exit(1);
  69. }
  70.  
  71. print STDERR "creating parser..." unless $quiet;
  72.  
  73. $parser = new Parse::RecDescent <<'EOA';
  74.  
  75. {
  76. #   use re 'eval';
  77.    $Parse::RecDescent::tokensep = '(?:\s*(?:(;[^\n]*\n))?)*';
  78.    
  79.    my $indent = 0;
  80.    my %sf2pf = (
  81.       'SF-IMAGE'    => 'PF_IMAGE,     ',
  82.       'SF-LAYER'    => 'PF_LAYER,     ',
  83.       'SF-CHANNEL'    => 'PF_CHANNEL,   ',
  84.       'SF-VALUE'    => 'PF_VALUE,     ',
  85.       'SF-TOGGLE'    => 'PF_TOGGLE,    ',
  86.       'SF-DRAWABLE'    => 'PF_DRAWABLE,  ',
  87.       'SF-STRING'    => 'PF_STRING,    ',
  88.       'SF-COLOR'    => 'PF_COLOUR,    ',
  89.       'SF-ADJUSTMENT'    => 'PF_ADJUSTMENT,',
  90.       'SF-FONT'        => 'PF_FONT,      ',
  91.       'SF-PATTERN'    => 'PF_PATTERN,   ',
  92.       'SF-GRADIENT'    => 'PF_GRADIENT,  ',
  93.       'SF-FILENAME'    => 'PF_FILE,      ',
  94.    );
  95.    my %constant = qw(
  96.       TRUE        1
  97.       FALSE        0
  98.       #t        1
  99.       #f        0
  100.       
  101.       RGB        RGB_IMAGE
  102.       RGBA        RGBA_IMAGE
  103.  
  104.       LINEAR        LINEAR_INTERPOLATION
  105.       
  106.       NORMAL        NORMAL_MODE
  107.       ADDITION        ADDITION_MODE
  108.       MULTIPLY        MULTIPLY_MODE
  109.       DIFFERENCE    DIFFERENCE_MODE
  110.       DARKEN_ONLY    DARKEN_ONLY_MODE
  111.       LIGHTEN_ONLY    LIGHTEN_ONLY_MODE
  112.       BEHIND        BEHIND_MODE
  113.       COLOR        COLOR_MODE
  114.       DISSOLVE        DISSOLVE_MODE
  115.       HUE        HUE_MODE
  116.       OVERLAY        OVERLAY_MODE
  117.       SATURATION    SATURATION_MODE
  118.       SCREEN        SCREEN_MODE
  119.       SUBTRACT        SUBTRACT_MODE
  120.       VALUE        VALUE_MODE
  121.  
  122.       ALPHA_MASK    ADD_ALPHA_MASK
  123.       BLACK_MASK    ADD_BLACK_MASK
  124.       WHITE_MASK    ADD_WHITE_MASK
  125.       
  126.       *pi*        3.14159265
  127.    );
  128.    my $constants = join("|",map {quotemeta} sort {length($b) <=> length($a)} keys %constant);
  129.    my %compat_fun = (
  130. cdr    => 'sub cdr {
  131.    my(@x)=@{$_[0]};
  132.    shift(@x);
  133.    @x >1 ? [@x] : $x[0];
  134. }',
  135.  
  136. cddr    => 'sub cddr {
  137.    my(@x)=@{$_[0]};
  138.    shift(@x); shift(@x);
  139.    @x >1 ? [@x] : $x[0];
  140. }',
  141.  
  142. max    => 'sub max {
  143.    $_[0] > $_[1] ? $_[0] : $_[1];
  144. }',
  145.  
  146. min    => 'sub min {
  147.    $_[0] < $_[1] ? $_[0] : $_[1];
  148. }',
  149.  
  150. fmod    => 'sub fmod {
  151.    $_[0] - int($_[0]/$_[1])*$_[1];
  152. }',
  153.  
  154. 'number->string' => 'sub number2string {
  155.    sprintf "%$_[1]d",$_[0];
  156. }',
  157.  
  158. nth    => 'sub nth {
  159.    $_[1]->[$_[0]];
  160. }',
  161.  
  162.    );
  163.    my $xskip;
  164.  
  165.    my $compat_fun = join("|",map {quotemeta} sort {length($b) <=> length($a)} keys %compat_fun);
  166.    
  167.    sub func2perl {
  168.       my($name)=@_;
  169.       $name=~s/->/2/g;
  170.       $name=~y/-*<>?!:\//_/;
  171.       $name=~/^[A-Za-z_]/ ? $name : "_$name";
  172.    }
  173.    
  174.    sub sf2pf {
  175.       my $name=lc $_[0];
  176.       $name=~y/ -?!:<>\[]/__/d;
  177.       $name=~s/_*[()].*$/"/;
  178.       $name=~s/_\d*_/_/g;
  179.       $name=~s/_+$//;
  180.       sprintf "%-20s","'$name',";
  181.    }
  182. }
  183.  
  184. script    : ( ...!/$/ stmt)(s) nl /$/
  185.     | <error:unable to recognize next statement>
  186.  
  187. stmts    : ( ...!')' nl stmt)(s?)
  188.  
  189. stmt    : '(' command ')'
  190.     | expr gen[";"]
  191.  
  192. command    : cp_expr gen[";"]
  193.     | c_let
  194.     | c_set
  195.     | c_if
  196.     | c_while
  197.     | e_cond gen[";"]
  198.     | c_aset
  199.     | c_defun
  200.     | c_define
  201.     | c_reg
  202.     | /print\b/ gen["print "] expr gen[",'\n';"]
  203.     | e_call gen[";"]
  204.     | atom gen[";"]
  205.     | <error:unrecognized statement>
  206.  
  207. expr    : '(' e_if ')'
  208.     | '(' gen["("] e_cond gen[")"] ')'
  209.     | '(' cp_expr ')'
  210.     | '(' ...!pdbfun e_call ')'
  211.     | '(' ...pdbfun gen["["] e_call gen["]"] ')'
  212.     | '(' gen["do {"] incindent nl command decindent nl gen["}"] ')'
  213.     | atom
  214.     | ...!')' <error:unrecognized expression>
  215.  
  216. cp_expr    : /car\b/   '(' ...pdbfun e_call ')'
  217.     
  218.     | e_begin
  219.     | e_list
  220.     | '=' expr 'TRUE'
  221.     | '=' 'TRUE' expr
  222.     | '=' gen["!"] expr 'FALSE'
  223.     | '=' gen["!"] 'FALSE' expr
  224.     | '-' gen["-("] expr ...')' gen[")"]
  225.     | m{[-+]|and\b} gen["("] e_binop[$item[1]] gen[")"]
  226.     | m{<=|>=|!=|[*/<>]|or\b} e_binop[$item[1]]
  227.     | '=' e_binop["=="]
  228.     | /eq\?|eqv\?|equal\?/ '()' expr gen[" eq ''"]            #X#
  229.     | /eq\?|eqv\?|equal\?/ e_binop["eq"]
  230.     | /realtime\b/ gen["time"]
  231.     | /modulo\b/ expr gen[" % "] expr
  232.     | 'divide?' gen["!"] expr gen["%"] expr
  233.     | 'string-append' expr (...!')' gen["."] expr)(s?)
  234.     | 'number->string' expr ...')'
  235.     | 'cons-array' gen["("] expr (gen[","] expr)(?) gen[",[])"]
  236.     | 'symbol-bound?' string '(' ident ')' gen["0"]
  237.     
  238.     | /aref\b/ expr gen["->["] expr gen["]"]
  239.     
  240.     | /$compat_fun/ { $::add_funcs{$compat_fun{$item[1]}}++ } <reject>
  241.     | /car\b/   gen["\@{"] expr gen["}[0]"]
  242.     | /cadr\b/  gen["\@{"] expr gen["}[1]"]
  243.     | /caddr\b/ gen["\@{"] expr gen["}[2]"]
  244.     | 'null?' gen["!\@{"] expr gen["}"]
  245.     | /cons\b/  gen["["] expr gen[", "] expr gen["]"]
  246.     
  247.     | ...')' gen["[]"]
  248.     | '(' cp_expr ')'
  249.     | constant
  250.  
  251. pdbfun    : /gimp-|plug-in-|script-fu-|file-|extension-/
  252.  
  253. atom    : constant
  254.     | 'gimp-data-dir' gen["'/usr/local/share/gimp'"]
  255.     | ident gen["\$$item[-1]"]
  256.     | numeral
  257.     | string gen[$item[-1]]
  258.     | list
  259.     | "'not-guile" gen["1"]
  260.  
  261. e_dot    : 'string-append' expr gen["."] expr
  262.  
  263. c_defun    : 'define' '(' <commit> ident
  264.         nl gen["sub $item[-2] {"] incindent
  265.         nl (...!')'
  266.             gen["my ("]
  267.             pardef (...!')' gen[", "] pardef)(s?)
  268.             gen[") = \@_;"]
  269.         )(?)
  270.       ')'
  271.       stmts decindent
  272.       nl gen["}"] nl
  273.  
  274. #c_define: 'define' ident gen["sub $item[-1] {"] incindent
  275. #      (nl command | stmts ) decindent
  276. #      nl gen["}"] nl
  277.  
  278. c_define: 'define' ident gen["\$$item[-1] = "] expr gen[";"]
  279.  
  280. pardef    : ident gen["\$$item[-1]"]
  281.  
  282. c_reg    : 'script-fu-register' <commit>
  283.       string string string
  284.       string string string
  285.       string
  286.       {
  287.         $item[1]=func2perl(substr($item[3],1,length($item[3])-2));
  288.         $item[3]=~s/script-fu/perl_fu/;
  289.         $item[3]=~y/-/_/;
  290.         $item[4]=~s/Script-Fu/Perl-Fu/;
  291.         $item[5]=~s/\s{2,}/ /g;
  292.       }
  293.       nl gen["register "] incindent
  294.          gen[$item[3]] gen[","]
  295.       nl gen[$item[5]] gen[","]
  296.       nl gen[$item[5]] gen[","]
  297.       nl gen[$item[6]] gen[","]
  298.       nl gen[$item[7]] gen[","]
  299.       nl gen[$item[8]] gen[","]
  300.       nl gen[$item[4]] gen[","]
  301.       nl gen[$item[9]] gen[","]
  302.       nl gen["["] incindent
  303.       ( <reject:$arg[0]!~/^.<Image>/> skip paramdef paramdef unskip )[$item[4]](?)
  304.       (...!')' paramdef)(s?)
  305.       decindent
  306.       nl gen["],"]
  307.       nl gen["\\&$item[1];"]
  308.       decindent
  309.  
  310. paramdef: /SF-\w+/
  311.       nl
  312.       gen["["] gen[$sf2pf{$item[1]}]
  313.       string gen[sf2pf($item[-1])."$item[-1], "]
  314.       ( '"TRUE"' gen["1"]
  315.       | '"FALSE"' gen["0"]
  316.       | expr
  317.       ) gen["],"]
  318.  
  319. e_call    : ( /script-fu-[A-Za-z_*][A-Za-z0-9-_*]*/
  320.         gen["\"$item[-1]\"->(RUN_NONINTERACTIVE, "]
  321.       | ident gen["$item[-1] ("]
  322.       )
  323.       (...!')'
  324.           expr (...!')' gen[", "] expr)(s?)
  325.       )[@arg](?)
  326.       gen[")"]
  327.  
  328. c_set    : /set!?/ <commit>
  329.       ident gen["\$$item[-1] = "]
  330.       expr
  331.       gen[";"]
  332.  
  333. c_aset    : /aset\b/ <commit>
  334.       ident gen["\$$item[-1]\->["] expr gen["] = "] expr gen[";"]
  335.  
  336. c_let    : /let(\*|rec)?/ <commit>
  337.       gen["do {"] incindent
  338.       '(' let_expr(s) ')' nl
  339.       stmts (expr gen[";"])(?) decindent
  340.       nl gen["};"]
  341.  
  342. let_expr: ...!')' nl '(' ident gen["my \$$item[-1] = "] expr gen[";"] ')'
  343.  
  344. e_begin    : /begin\b|prog1\b/ <commit>
  345.       gen["do {"] incindent
  346.       stmts decindent
  347.       nl gen["}"]
  348.  
  349. e_if    : 'if' <commit>
  350.       gen["("] expr gen[") ? ("] expr gen[") : ("] expr gen[")"]
  351.  
  352. c_if    : 'if' <commit>
  353.       gen["if ("] expr gen[") {"] incindent
  354.       nl stmt decindent
  355.       nl gen["}"]
  356.       ( '(' ')'
  357.       |
  358.          (...!')'
  359.             gen[" else {"] incindent
  360.             nl stmt decindent
  361.             nl gen["}"]
  362.          )(?)
  363.       )
  364.  
  365. c_while    : 'while' <commit>
  366.       nl gen["while ("] expr gen[") {"] incindent
  367.       stmts decindent
  368.       nl gen["}"]
  369.  
  370. e_cond    : 'cond' <commit>
  371.       cond
  372.  
  373. cond    : '(' 
  374.       ( /'?else\b/ expr ')'
  375.       | expr gen[" ? "] expr incindent nl gen[": "] ')' decindent
  376.         ( ...'(' cond | gen["die 'cond fell off the end'"] )
  377.       )
  378.  
  379. e_binop    : expr
  380.           (...!')'
  381.          gen[" $arg[0] "]
  382.          expr
  383.       )[@arg](s?)
  384.     
  385. e_list    : 'list' gen["["] (expr (...!')' gen[", "] expr)(s?))(?) gen["]"]
  386.  
  387. ident    : /[A-Za-z0-9-#_*!?<>=\/]+/ <reject:$item[1]!~/[A-Za-z]/>
  388.       { func2perl($item[1]) }
  389.  
  390. numeral    : /-?(?:\d+(?:\.\d*)?|\.\d+)/ gen[$item[-1]]
  391.  
  392. string    : /"([^\\"]+|\\.)*"/        { $item[1]=~s/([\$\@])/\\$1/g; $item[1] }
  393.     | /'[A-Za-z0-9-_*!?<>=\/]+/ { $item[1]=~s/([\$\@])/\\$1/g; '"'.substr($item[1],1).'"' }
  394.  
  395. list    : "'(" gen["["] (expr (...!')' gen[", "] expr)(s?))(?) gen["]"] ')'
  396.  
  397. constant: /(?:$constants)(?=[ \t;)\n\r])/ gen[$constant{$item[-1]}]
  398.     | /[A-Z-_]{3,}/                   gen[func2perl($item[-1])]
  399.  
  400.  
  401. nl:        gen["\n".("   " x $indent)]
  402. incindent:    { printf STDERR " %2d%%\b\b\b\b",$thisoffset*100/$::filesize unless $::quiet } { $indent++ }
  403. decindent:    { $indent-- }
  404. skip:        { $xskip++ }
  405. unskip:        { $xskip-- }
  406. gen:        ( <reject:$xskip> <defer: print ::OUT $arg[0] > )[@arg](?)
  407. #gen:        { $xskip or print $arg[0] } #d#
  408.  
  409. EOA
  410.  
  411. $parser or die;
  412. print STDERR "done\n" unless $quiet;
  413.  
  414. #$RD_TRACE=15;
  415.  
  416. sub convert {
  417.    my($in,$out)=@_;
  418.    
  419.    open IN,"<$in\0"   or die "unable to open '$in' for reading: $!";
  420.    open OUT,">$out\0" or die "unable to open '$out' for writing: $!";
  421.    
  422.    print STDERR "header..." unless $quiet;
  423.    print OUT <<EOA;
  424. #!/usr/bin/perl
  425.  
  426. use Gimp qw(:auto);
  427. use Gimp::Fu;
  428. EOA
  429.  
  430.    print STDERR "reading($in)..." unless $quiet;
  431.    { local $/; $file = <IN> }
  432.    $file =~ s/;.*?$//gm;
  433.    $::filesize = length $file; # make it clear this is a _global_ variable
  434.  
  435.    print STDERR "translating..." unless $quiet;
  436.    $parser->script ($file);
  437.  
  438.    print STDERR "trailer..." unless $quiet;
  439.    print OUT "\n",join("\n\n",keys %add_funcs),"\n" if %add_funcs;
  440.    print OUT <<'EOA';
  441.  
  442. exit main;
  443. EOA
  444.    
  445.    print STDERR "wrote($out)\n" unless $quiet;
  446. }
  447.  
  448. for $x (@ARGV) {
  449.    (my $y=$x)=~s/\.scm/.pl/i or die "source file '$x' has no .scm extension";
  450.    convert($x,$y);
  451. }
  452.  
  453.